VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCancelDirective"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Function CancelDirective(arParameters As Variant, Optional strFailReason As String) As Boolean

    'Variables
    Dim RSXML As ADODB.Recordset
    Dim rsIndex As ADODB.Recordset
    Dim rsMeaning As ADODB.Recordset
    Dim adoComm As ADODB.Command
    Dim adoConn As ADODB.Connection
    
    Dim blGetHeaderData As Boolean
    Dim blSaveHeader As Boolean
    
    Dim strSql As String
    Dim strOraErr As String
    'Dim lngInterfaceNo As Long
    Dim strUserId As String
    Dim strEmailAdrr As String
    
    Dim lngReqSeqNum As String
    Dim strMeaning As String
    
    Dim lngRecordsAffected As Long

    On Error GoTo CancelDirectiveFix

    lngInterfaceNo = CLng(arParameters(0))
    strUserId = arParameters(1)
    strEmailAdrr = arParameters(2)
    
    Set adoConn = New ADODB.Connection
    With adoConn
        .CursorLocation = adUseClient
        .ConnectionString = GetConnectionString() 'Johann (20090625): Centralised code for connection string added
        .open
    End With
    
    Set RSXML = New ADODB.Recordset
    With RSXML
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
    End With
    
    Set adoComm = New ADODB.Command
    With adoComm
        .CommandText = "select x.xml_string from dir_interface_xml x where  x.interface_no = " & lngInterfaceNo
        .CommandType = adCmdText
        Set .ActiveConnection = adoConn
    End With
    
    Set RSXML = adoComm.Execute
        
    XMLString = RSXML.fields("xml_string").Value

    'Extract Header Data
    If XMLString <> "" Then
        Dim dllGetHeaderData As clsGetHeader
        Set dllGetHeaderData = New clsGetHeader
            blGetHeaderData = dllGetHeaderData.GetHeaderData()
    Else
        CancelDirective = False
        Exit Function
    End If
    
    'Save Header Data
    'Save Header Data to database for future use. When the response is received from SARS
    'this data will be used to build the header and trailer for the xml doc that is being
    'sent back to BPC
    If blGetHeaderData = True Then
        Dim dllSaveHeader As clsSaveHeader
        Set dllSaveHeader = New clsSaveHeader
            blSaveHeader = dllSaveHeader.SaveHeader()
    Else
        CancelDirective = False
        Exit Function
    End If
    
    'Update dir_interface_index table - set sars_response_yn = N
    If nReqSeqNum <> "" Then
        Dim dllUpdateIndex As clsUpdateIndex
        Set dllUpdateIndex = New clsUpdateIndex
        Dim blUpdateIndex As Boolean
        blUpdateIndex = dllUpdateIndex.UpdateIndex()
        'GetProcessForm = sDataSaved & vbCrLf & sUpdateIndex
    Else
        CancelDirective = False
        Exit Function
    End If
        
    'initilize the recordset
    Set rsIndex = New ADODB.Recordset
    rsIndex.CursorType = adOpenKeyset
    rsIndex.LockType = adLockOptimistic
    
    'initilize the recordset
    Set rsMeaning = New ADODB.Recordset
    rsMeaning.CursorType = adOpenKeyset
    rsMeaning.LockType = adLockOptimistic
    
    'Update the dir_response table - set cancel_process_status = CA
    'Get the ReqSeqNum from the db
    strSql = "Select REQ_SEQ_NUM from DIR_INTERFACE_INDEX where INTERFACE_NO =" & lngInterfaceNo
    
    Set rsIndex = adoConn.Execute(strSql)
    
    If rsIndex.RecordCount > 0 Then
        lngReqSeqNum = rsIndex!REQ_SEQ_NUM
        
        strSql = "Select REQ_SEQ_NUM from DIR_RESPONSE where REQ_SEQ_NUM =" & lngReqSeqNum
        strSql = strSql & " and REQUEST_STATUS = '07'"
        
        Set rsIndex = adoConn.Execute(strSql)
        
        If rsIndex.RecordCount > 0 Then
                'Update dir_response to flag directive request marked for cancel
                strSql = "Update DIR_RESPONSE"
                strSql = strSql & " set CANCEL_PROCESS_STATUS = 'CA'"
                strSql = strSql & " where REQ_SEQ_NUM = " & lngReqSeqNum
        
                Set adoComm = New ADODB.Command
                  With adoComm
                    .CommandText = strSql
                    .CommandType = adCmdText
                    Set .ActiveConnection = adoConn
                    .Execute lngRecordsAffected
                End With
                
                If lngRecordsAffected = 1 Then
                    CancelDirective = True
                Else
                    CancelDirective = False
                    strFailReason = "Could not update cancel status for request number " & lngReqSeqNum
                End If
        Else
            strSql = "Select meaning from dir_system_codes where code = 'dir_req_status' and value in (Select request_status from dir_response where req_seq_num = " & lngReqSeqNum & ")"
            
            Set rsMeaning = adoConn.Execute(strSql)
            
            strMeaning = rsMeaning.fields("meaning").Value
            
            If rsMeaning.RecordCount > 0 Then
                strFailReason = "Could not update cancel status for request number " & lngReqSeqNum & ". Reason: " & strMeaning
                CancelDirective = False
            Else
                strFailReason = "Could not update cancel status for request number " & lngReqSeqNum & ". Reason: This is not an approved directive."
                CancelDirective = False
            End If
        End If
    Else
        strFailReason = "InterfaceNo: " & lngInterfaceNo & " not found in DIR_INTERFACE_INDEX. "
        CancelDirective = False
    End If
        
    If blSaveHeader = True And CancelDirective = True Then
        CancelDirective = True
    Else
        'Johann (20090708): Create an error file. this will also add an error message to the interface index
        'Dim objErrorFile As Object
        'Set objErrorFile = CreateObject("FileError.clsFileError")
        
        'If strFailReason <> "" Then
        '    Call objErrorFile.CreateErrorFile(CLng(lngInterfaceNo), "02", , , , strFailReason, strFailReason)
        'End If
        
        'Set objErrorFile = Nothing
        CancelDirective = False
        Exit Function
    End If

    
   Exit Function
   
CancelDirectiveFix:
    CancelDirective = False
    strFailReason = "strFailReason: " & Err.Number & " - " & Err.Descripti
End Function

'Private Function MarkAsCancelled(ReqSeqNum As String, Optional strFailReason As String) As Boolean
'
'    Dim strSql As String
'    Dim rsIndex As ADODB.Recordset
'
'    On Error GoTo MarkAsCancelledFix
'
'    'initilize the recordset
'    Set rsIndex = New ADODB.Recordset
'    rsIndex.CursorType = adOpenKeyset
'    rsIndex.LockType = adLockOptimistic
'
'
'
'    Exit Function
'
'MarkAsCancelledFix:
'    strFailReason = "MarkAsCancelled: " & Err.Number & " - " & Err.Description
'    MarkAsCancelled = False
'End Function

Public Function CreateApproveFile(lngInterfaceNo As Long, Optional strFailReason As String) As Boolean

    Dim objFileApprove As Object
    Dim strErrMsg As String
    
    Set objFileApprove = CreateObject("FileApprove.clsFileApprove")
    If objFileApprove.CreateApproveFile(lngInterfaceNo, strErrMsg) Then
    '(12 = the relavent interface number)
        CreateApproveFile = True
    Else
        CreateApproveFile = False
        strFailReason = "CreateApproveFile failed because : " & strErrMsg
    End If
    Set objFileApprove = Nothing





'    'decline
'    Dim strTempFile As String
'    Dim strXmlHeader As String
'    Dim strXmlVersDtdHeader As String
'    Dim strXmlError As String
'    Dim lngNewInterfaceNo As Long
'    Dim strNewMsgId As String
'
'    'approve
'    Dim strFileFmtErrMsg As String
'    Dim strDataValidErrMsg As String
'    Dim strOraErr As String
'
'    ClearIdxVars
'
'    If Not ConnectToDb(strOraErr) Then
'        MsgBox "Error connecting to database: " & strOraErr
'        Exit Function
'    End If
'
'    'barb: set these = nothing eventually
'    Set objFileError = New clsCancelDirective
'    Set objFunctions = New clsCancelFunctions
'    Set objReg = New clsReg
'    Set objSendEMail = New clsSendEMail
'
'    If objFunctions.ExtractIndexBlobFromDb(lngInterfaceNo) = True Then
'            If objFunctions.ValidateXmlFormat(strFileFmtErrMsg) Then
'                If objFunctions.GetHeaderData Then
'                    If objFunctions.ValidateHeaderData(strDataValidErrMsg) Then
'                        strXmlHeader = objFunctions.CreateXmlHeader
'                        'produce error file
'                        strXmlVersDtdHeader = objFunctions.CreateXmlVersionDtdHeader
'                        'If objFunctions.CreateFileApproval(strXmlHeader, strXmlError) Then
'                            adoConn.BeginTrans
'                            If objFunctions.InsertIntoInterfaceIndex(lngNewInterfaceNo, strNewMsgId) Then
'                                If objFunctions.InsertIntoInterfaceXml(lngNewInterfaceNo, strNewMsgId, strXmlVersDtdHeader, strXmlHeader) Then
'                                    adoConn.CommitTrans
'                                    MsgBox "Error file handled successfully"
'                                    CreateApproveFile = True
'                                Else
'                                    adoConn.RollbackTrans
'                                    MsgBox "Error file handle failed"
'                                    CreateApproveFile = False
'                                End If
'                                    MsgBox "Error file handled successfully"
'
'                            Else
'                                MsgBox "Error file handle failed"
'                            End If
''                        Else
''                            MsgBox "Error rejecting file"
''                        End If
'
'                        adoConn.BeginTrans
'                        If objFunctions.UpdateInterfaceIndex Then
'
'                        Else
'
'                        End If
'                    Else
'
'                    End If
'                Else
'
'                End If
'            Else
'
'            End If
'    Else
'
'    End If
'
End Function




    

'Public Function GetHeaderFromText() As String
'
'    Dim strTemp1 As String
'    Dim strTemp2 As String
'    Dim lPos As Long
'    Dim strTypeOfRequest As String
'
'    On Error GoTo GetHeaderFromTextFix
'
'    lPos = InStr(1, IdxVars.XmlString, "</Tracking>")
'    If lPos <> 0 Then
'        'get text up til end of header then close root node
'        strTemp1 = Mid(IdxVars.XmlString, 1, lPos + 11)
'        'remove version & dtd line
'        lPos = InStr(1, strTemp1, ".dtd") + 8
'        If lPos > 0 Then
'            strTemp2 = Mid(strTemp1, lPos, Len(strTemp1) - lPos)
'        End If
'        'change KeyTax Type to "10" for error
'        lPos = InStr(1, strTemp2, "<KeyTax Type=") + 13
'        If lPos > 0 Then
'            Select Case IdxVars.KeyTaxType
'                Case "01", "03", "07", "08"
'                Case Else
'                    IdxVars.KeyTaxType = Mid(strTemp2, lPos + 1, 2)
'            End Select
'            strTemp1 = Mid(strTemp2, 1, lPos) & "" & "10" & """"
'            strTemp1 = strTemp1 & Mid(strTemp2, lPos + 4, Len(strTemp2))
'        End If
'        'change the Request Status to "15" for error
'        lPos = InStr(1, strTemp1, "<RequestStatus Type=") + 20
'        If lPos > 0 Then
'            strTemp2 = Mid(strTemp1, 1, lPos) & "" & "15" & """"
'            strTemp2 = strTemp2 & Mid(strTemp1, lPos + 4, Len(strTemp1))
'        End If
'
'        strTemp2 = strTemp2 & "</KeyTax>"
'
'
'        GetHeaderFromText = strTemp2
'    Else
'        GetHeaderFromText = ""
'    End If
'
'    Exit Function
'
'GetHeaderFromTextFix:
'    MsgBox "GetHeaderFromText: " & Err.Number & " - " & Err.Description
'End Function
'********************************************************************************************************
'Private Sub ClearIdxVars()
'
'    'barb: start here
'    'validation + "" and "NULL"
'    'clean up
'    'johan to write to created_date
'    'sort out dtd location
'    'remove all apostrophes from database data before inserting/updating
'
'    IdxVars.InterfaceNo = 0
'    IdxVars.XmlString = ""
'    IdxVars.CreatedDated = ""
'    IdxVars.SarsResponseYn = ""
'    IdxVars.KeyTaxType = ""
'    IdxVars.MqStatus = ""
'
'    'Tracking Vars
'    IdxVars.Tracking.MsgId = ""
'    IdxVars.Tracking.ComId = ""
'    IdxVars.Tracking.BuId = ""
'    IdxVars.Tracking.ReferenceId = ""
'    IdxVars.Tracking.ReqSeqNum = ""
'    IdxVars.Tracking.RequestStatus = ""
'
'    'Requestor Vars
'    IdxVars.Request.Date = ""
'    IdxVars.Request.Email = ""
'    IdxVars.Request.Name = ""
'    IdxVars.Request.Time = ""
'    IdxVars.Request.UserId = ""
'
'End Sub

